home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / simcode.arc / COMP.PAS < prev    next >
Pascal/Delphi Source File  |  1984-10-14  |  7KB  |  280 lines
  1. {$symtab-,$linesize:131,$pagesize:86,
  2. $title:'COMP.PAS -- Compiler for Scripts'}
  3. {    COPYRIGHT @ 1982
  4.     Jim Holtman and Eric Holtman
  5.     35 Dogwood Trail
  6.     Randolph, NJ 07869
  7.     (201) 361-3395
  8. }
  9.  
  10.  module scrcomp;
  11.  
  12.     var
  13.        state_number [public] : integer;
  14.        gen_label_num [public] : integer;
  15.        comp_file_name [public] : lstring(20);
  16.        value state_number := 0;
  17.        gen_label_num := 10000;
  18. {$include:'token.h'}
  19. {$include:'graph.inc'}
  20.  
  21.     procedure savescreen;
  22.  
  23.        external;
  24.  
  25.     procedure restorescreen;
  26.  
  27.        external;
  28.  
  29.     function next_token(var d : lstring;
  30.      var fd : text) : integer;
  31.  
  32.        external;
  33.  
  34.     procedure endxqq;
  35.  
  36.        external;
  37.  
  38.     procedure print_error(const m:lstring;
  39.      i : integer);
  40.  
  41.        external;
  42.  
  43.     procedure putbchar(c : char);
  44.  
  45.        external;
  46.  
  47.     procedure putbstr(const s : lstring);
  48.  
  49.        external;
  50.  
  51.     procedure compile(var nam:lstring) [public];
  52.  
  53.        var
  54.       fil : text;
  55.       outf : text;
  56.  
  57.        procedure outstr(var fd : text;
  58.         a,b,c,d : integer;
  59.         const s : lstring);
  60.  
  61.       begin
  62.          writeln(fd,a,b,c,d,' ',s);
  63.          end;
  64.  
  65.        function gen_lab : integer;
  66.  
  67.       begin
  68.          gen_label_num := gen_label_num + 100;
  69.          gen_lab := gen_label_num;
  70.          end;
  71.  
  72.        function sentence : integer;
  73.  
  74.       forward;
  75.  
  76.        procedure do_func(arg : integer);
  77.  
  78.       var
  79.          token : lstring(255);
  80.          t : integer;
  81.  
  82.       begin
  83.          t := next_token(token, fil);
  84.          if (t <> TOK_STR) then begin
  85.         print_error('Error: String constant expected',ord(token.len));
  86.         return;
  87.         end;
  88.          outstr(outf, state_number, arg, state_number+1, 0,token);
  89.          end;
  90.  
  91.        procedure clause(go_lab, ret_lab : integer);
  92.  
  93.       var
  94.          o_stnum : integer;
  95.          token : lstring(255);
  96.          t_typ : integer;
  97.  
  98.       begin
  99.          o_stnum := state_number;
  100.          state_number := go_lab;
  101.          t_typ := next_token(token, fil);
  102.          if (t_typ <> TOK_LBRACK) then begin
  103.         putbchar(' ');
  104.         putbstr(token);
  105.         eval(sentence);
  106.         outstr(outf, state_number+1, A_NGOTO, ret_lab, 0,
  107.              'non { return');
  108.         end
  109.          else begin
  110.         repeat
  111.            t_typ := sentence;
  112.            until t_typ = -1;
  113.         outstr(outf, state_number, A_NGOTO, ret_lab, 0, 'return');
  114.         end;
  115.          state_number := o_stnum;
  116.          end;
  117.  
  118.        procedure do_if;
  119.  
  120.       var
  121.          token : lstring(255);
  122.          t_typ : integer;
  123.          if_lab, else_lab : integer;
  124.          onum : integer;
  125.          otoken : lstring(255);
  126.  
  127.       begin
  128.          t_typ := next_token(token, fil);
  129.          if (t_typ <> TOK_STR) then begin
  130.         print_error('Error: string constant expected',ord(token.len));
  131.         return;
  132.         end;
  133.          if_lab := gen_lab;
  134.          else_lab := gen_lab;
  135.          onum := state_number;
  136.          copylst(token, otoken);
  137.          clause(if_lab-1, state_number+1);
  138.          t_typ := next_token(token, fil);
  139.          if (t_typ <> TOK_ELSE) then begin
  140.         putbchar(' ');
  141.         putbstr(token);
  142.         else_lab := onum + 1;
  143.         end
  144.          else begin
  145.         clause(else_lab-1, state_number + 1);
  146.         end;
  147.          outstr(outf, onum, A_EXPECT, if_lab, else_lab,otoken);
  148.          end;
  149.  
  150.        procedure do_case;
  151.  
  152.       var
  153.          token : lstring(255);
  154.          t_typ : integer;
  155.          case_lab : integer;
  156.          st_lab : integer;
  157.          onum : integer;
  158.          otoken : lstring(255);
  159.          done_other : boolean;
  160.          other_lab : integer;
  161.  
  162.       begin
  163.          case_lab := gen_lab+1;
  164.          other_lab := case_lab - 1;
  165.          done_other := false;
  166.          outstr(outf, state_number, A_CASE, case_lab, 0, 'CASE START');
  167.          while true do begin
  168.         t_typ := next_token(token, fil);
  169.         if (t_typ <> TOK_LABEL) and (t_typ <> TOK_CASEEND) and (t_typ <>
  170.              TOK_OTHERWISE) then begin
  171.            print_error('Error: LABEL or caseend expected',ord(token.len)
  172.             );
  173.            return;
  174.            end;
  175.         if (t_typ = TOK_CASEEND) then begin
  176.            if (done_other = false) then begin
  177.               print_error('Warning: no OTHERWISE in CASE',ord(token.len)
  178.                );
  179.               outstr(outf, other_lab, TOK_CASE, state_number+1, 0,
  180.                'OTHERWISE');
  181.               end;
  182.            outstr(outf, case_lab, TOK_CASEEND, 0, 0, token);
  183.            return;
  184.            end
  185.         else if (t_typ = TOK_OTHERWISE) then begin
  186.            if (done_other = true) then begin
  187.               print_error('Error: more than one otherwise in CASE',ord(
  188.                token.len));
  189.               return;
  190.               end;
  191.            st_lab := gen_lab;
  192.            outstr(outf, other_lab, TOK_CASE, st_lab, 0, 'OTHERWISE');
  193.            clause(st_lab-1, state_number+1);
  194.            done_other := true;
  195.            end
  196.         else begin
  197.            delete(token, ord(token.len), 1);
  198.            st_lab := gen_lab;
  199.            outstr(outf, case_lab, TOK_CASE, st_lab, 0, token);
  200.            clause(st_lab-1, state_number+1);
  201.            case_lab := case_lab + 1;
  202.            end;
  203.         end;
  204.          end;
  205.  
  206.        function sentence;
  207.  
  208.       var
  209.          token : lstring(255);
  210.          t_typ : integer;
  211.  
  212.       begin
  213.          t_typ := next_token(token, fil);
  214.          if (t_typ > -1) then begin
  215.         state_number := state_number + 1;
  216.         case t_typ of
  217.            TOK_IF: do_if;
  218.            TOK_DIAL: do_func(A_DIAL);
  219.            TOK_SEND: do_func(A_SEND);
  220.            TOK_SAY: do_func(A_SAY);
  221.            TOK_GOTO: do_func(A_LGOTO);
  222.            TOK_GOSUB: do_func(A_GOSUB);
  223.            TOK_RETURN: outstr(outf, state_number, A_RETURN,
  224.             state_number+1, 0, 'return');
  225.            TOK_LABEL: begin
  226.               token.len := token.len - 1;
  227.               outstr(outf, state_number, A_LABEL, state_number+1, 0,
  228.                token);
  229.               end;
  230.            TOK_CLOSELOG: begin
  231.               outstr(outf, state_number, A_CLOSELOG, state_number+1, 0,
  232.                'CLOSELOG');
  233.               end;
  234.            TOK_TOGGLE_TR: begin
  235.               outstr(outf, state_number, A_TOGGLE_TR, state_number+1, 0,
  236.                'TOGGLE_TR');
  237.               end;
  238.            TOK_NAME: do_func(A_ENTRY);
  239.            TOK_RBRACK: begin
  240.               sentence := -1;
  241.               return;
  242.               end;
  243.            TOK_QUIT: outstr(outf, state_number, -1, -1, -1, 'HALT');
  244.            TOK_INPUT: do_func(A_INPUT);
  245.            TOK_SETTIME: do_func(A_SETTIME);
  246.            TOK_CASE: do_case;
  247.            TOK_OPENLOG: do_func(A_OPENLOG);
  248.            otherwise
  249.               begin
  250.              print_error('Error: Unknown keyword', ord(token.len));
  251.              return;
  252.              end;
  253.            end;
  254.         end;
  255.          sentence := 0;
  256.          end;
  257.  
  258.        begin
  259.       savescreen;
  260.       xxcls;
  261.       xxmove(0,0);
  262.       writeln('File "',nam,'" is not compiled.');
  263.       assign(fil, nam);
  264.       reset(fil);
  265.       copylst(nam,comp_file_name);
  266.       write('Name of file to contain compiled scripts: ');
  267.       readln(nam);
  268.       assign(outf, nam);
  269.       rewrite(outf);
  270.       writeln(outf,'#compiled');
  271.       while (not eof(fil)) do eval(sentence);
  272.       putbstr('quit ');
  273.       eval(sentence);
  274.       close(outf);
  275.       writeln('Hit return to continue-----');
  276.       readln;
  277.       restorescreen;
  278.       end;
  279.  end.
  280.